home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / c / block.c < prev    next >
C/C++ Source or Header  |  1987-06-04  |  2KB  |  110 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.  
  9.     block.c
  10.  
  11.     blocks and exits
  12. */
  13.  
  14. #include "include.h"
  15.  
  16. object Sblock;
  17.  
  18. Fblock(args)
  19. object args;
  20. {
  21.     object *oldlex = lex_env;
  22.     object id;
  23.     object body;
  24.     object *top;
  25.  
  26.     if(endp(args))
  27.         FEtoo_few_argumentsF(args);
  28.     lex_copy();
  29.     id = alloc_frame_id();
  30.     vs_push(id);
  31.     lex_block_bind(MMcar(args), id);
  32.     vs_pop;
  33.     frs_push(FRS_CATCH, id);
  34.     if (nlj_active)
  35.         nlj_active = FALSE;
  36.     else {
  37.         body = MMcdr(args);
  38.         if (endp(body)) {
  39.             vs_base = vs_top;
  40.             vs_push(Cnil);
  41.         } else {
  42.             top = vs_top;
  43.             do {
  44.                 vs_top = top;
  45.                 eval(MMcar(body));
  46.                 body = MMcdr(body);
  47.             } while (!endp(body));
  48.         }
  49.     }
  50.     frs_pop();
  51.     lex_env = oldlex;
  52. }
  53.  
  54. Freturn_from(args)
  55. object args;
  56. {
  57.     object lex_block;
  58.     frame_ptr fr;
  59.  
  60.     if (endp(args))
  61.         FEtoo_few_argumentsF(args);
  62.     if (!endp(MMcdr(args)) && !endp(MMcddr(args)))
  63.         FEtoo_many_argumentsF(args);
  64.     lex_block = lex_block_sch(MMcar(args));
  65.     if (MMnull(lex_block))
  66.         FEerror("The block name ~S is undefined.", 1, MMcar(args));
  67.     fr = frs_sch(MMcaddr(lex_block));
  68.     if(fr == NULL)
  69.         FEerror("The block ~S is missing.", 1, MMcar(args));
  70.     if(endp(MMcdr(args))) {
  71.         vs_base = vs_top;
  72.         vs_push(Cnil);
  73.     }
  74.     else
  75.         eval(MMcadr(args));
  76.     unwind(fr, MMcaddr(lex_block));
  77.     /*  never reached  */
  78. }
  79.  
  80. Freturn(args)
  81. object args;
  82. {
  83.     object lex_block;
  84.     frame_ptr fr;
  85.  
  86.     if(!endp(args) && !endp(MMcdr(args)))
  87.         FEtoo_many_argumentsF(args);
  88.     lex_block = lex_block_sch(Cnil);
  89.     if (MMnull(lex_block))
  90.          FEerror("The block name ~S is undefined.", 1, Cnil);
  91.     fr = frs_sch(MMcaddr(lex_block));
  92.     if (fr == NULL)
  93.         FEerror("The block ~S is missing.", 1, Cnil);
  94.     if(endp(args)) {
  95.         vs_base = vs_top;
  96.         vs_push(Cnil);
  97.     } else
  98.         eval(MMcar(args));
  99.     unwind(fr, MMcaddr(lex_block));
  100.     /*  never reached  */
  101. }
  102.  
  103. init_block()
  104. {
  105.     Sblock = make_special_form("BLOCK", Fblock);
  106.     enter_mark_origin(&Sblock);
  107.     make_special_form("RETURN-FROM", Freturn_from);
  108.     make_special_form("RETURN", Freturn);
  109. }
  110.